home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / efs / dired-rgxp.el.z / dired-rgxp.el
Encoding:
Text File  |  1998-05-21  |  10.1 KB  |  268 lines
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;;
  3. ;; File:           dired-rgxp.el
  4. ;; Dired Version: #Revision: 7.9 $
  5. ;; RCS:
  6. ;; Description:   Commands for running commands on files whose names
  7. ;;                match a regular expression.
  8. ;;
  9. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  10.  
  11. ;;; Requirements and provisions
  12. (provide 'dired-rgxp)
  13. (require 'dired)
  14.  
  15. ;;; Variables
  16.  
  17. (defvar dired-flagging-regexp nil)
  18. ;; Last regexp used to flag files.
  19.  
  20. ;;; Utility functions
  21.  
  22. (defun dired-do-create-files-regexp
  23.   (file-creator operation arg regexp newname &optional whole-path marker-char)
  24.   ;; Create a new file for each marked file using regexps.
  25.   ;; FILE-CREATOR and OPERATION as in dired-create-files.
  26.   ;; ARG as in dired-get-marked-files.
  27.   ;; Matches each marked file against REGEXP and constructs the new
  28.   ;;   filename from NEWNAME (like in function replace-match).
  29.   ;; Optional arg WHOLE-PATH means match/replace the whole pathname
  30.   ;;   instead of only the non-directory part of the file.
  31.   ;; Optional arg MARKER-CHAR as in dired-create-files.
  32.   (let* ((fn-list (dired-get-marked-files nil arg))
  33.      (name-constructor
  34.       (if whole-path
  35.           (list 'lambda '(from)
  36.             (list 'let
  37.               (list (list 'to
  38.                       (list 'dired-string-replace-match
  39.                         regexp 'from newname)))
  40.               (list 'or 'to
  41.                 (list 'dired-log
  42.                       '(buffer-name (current-buffer))
  43.                       "%s: %s did not match regexp %s\n"
  44.                       operation 'from regexp))
  45.               'to))
  46.         (list 'lambda '(from)
  47.           (list 'let
  48.             (list (list 'to
  49.                     (list 'dired-string-replace-match regexp
  50.                       '(file-name-nondirectory from)
  51.                       newname)))
  52.             (list 'or 'to
  53.                   (list 'dired-log '(buffer-name (current-buffer))
  54.                     "%s: %s did not match regexp %s\n"
  55.                     operation '(file-name-nondirectory from)
  56.                     regexp))
  57.             '(and to
  58.                   (expand-file-name
  59.                    to (file-name-directory from)))))))
  60.      (operation-prompt (concat operation " `%s' to `%s'?"))
  61.      (rename-regexp-help-form (format "\
  62. Type SPC or `y' to %s one match, DEL or `n' to skip to next,
  63. `!' to %s all remaining matches with no more questions."
  64.                       (downcase operation)
  65.                       (downcase operation)))
  66.      (query (list 'lambda '(from to)
  67.               (list 'let
  68.                 (list (list 'help-form
  69.                     rename-regexp-help-form))
  70.                 (list 'dired-query
  71.                   '(quote dired-file-creator-query)
  72.                   operation-prompt
  73.                   '(dired-abbreviate-file-name from)
  74.                   '(dired-abbreviate-file-name to))))))
  75.     (dired-create-files
  76.      file-creator operation fn-list name-constructor marker-char query)))
  77.  
  78. (defun dired-mark-read-regexp (operation)
  79.   ;; Prompt user about performing OPERATION.
  80.   ;; Read and return list of: regexp newname arg whole-path.
  81.   (let* ((whole-path
  82.       (equal 0 (prefix-numeric-value current-prefix-arg)))
  83.      (arg
  84.       (if whole-path nil current-prefix-arg))
  85.      (regexp
  86.       (dired-read-with-history
  87.        (concat (if whole-path "Path " "") operation " from (regexp): ")
  88.        dired-flagging-regexp 'dired-regexp-history))
  89.      (newname
  90.       (read-string
  91.        (concat (if whole-path "Path " "") operation " " regexp " to: ")
  92.        (and (not whole-path) (dired-dwim-target-directory)))))
  93.     (list regexp newname arg whole-path)))
  94.  
  95. ;;; Marking file names matching a regexp.
  96.  
  97. (defun dired-mark-files-regexp (regexp &optional marker-char omission-files-p)
  98.   "\\<dired-mode-map>Mark all files matching REGEXP for use in later commands.
  99.  
  100. A prefix argument \\[universal-argument] means to unmark them instead.
  101.  
  102. A prefix argument 0 means to mark the files that would me omitted by \\[dired-omit-toggle].
  103. A prefix argument 1 means to unmark the files that would be omitted by \\[dired-omit-toggle].
  104.  
  105. REGEXP is an Emacs regexp, not a shell wildcard.  Thus, use \"\\.o$\" for
  106. object files--just `.o' will mark more than you might think.  The files \".\"
  107. and \"..\" are never marked.
  108. "
  109.   (interactive
  110.    (let ((unmark (and (not (eq current-prefix-arg 0)) current-prefix-arg))
  111.      (om-files-p (memq current-prefix-arg '(0 1)))
  112.      regexp)
  113.      (if om-files-p
  114.      (setq regexp (dired-omit-regexp))
  115.        (setq regexp (dired-read-with-history
  116.             (concat (if unmark "Unmark" "Mark")
  117.                 " files (regexp): ") nil
  118.                 'dired-regexp-history)))
  119.      (list regexp (if unmark ?\ ) om-files-p)))
  120.   (let ((dired-marker-char (or marker-char dired-marker-char)))
  121.     (dired-mark-if
  122.      (and (not (looking-at dired-re-dot))
  123.       (not (eolp))            ; empty line
  124.       (let ((fn (dired-get-filename nil t)))
  125.         (and fn (string-match regexp (file-name-nondirectory fn)))))
  126.      (if omission-files-p
  127.      "omission candidate file"
  128.        "matching file"))))
  129.  
  130. (defun dired-flag-files-regexp (regexp)
  131.   "In dired, flag all files containing the specified REGEXP for deletion.
  132. The match is against the non-directory part of the filename.  Use `^'
  133.   and `$' to anchor matches.  Exclude subdirs by hiding them.
  134. `.' and `..' are never flagged."
  135.   (interactive (list (dired-read-with-history
  136.               "Flag for deletion (regexp): " nil
  137.               'dired-regexp-history)))
  138.   (dired-mark-files-regexp regexp dired-del-marker))
  139.  
  140. (defun dired-mark-extension (extension &optional marker-char)
  141.   "Mark all files with a certain extension for use in later commands.
  142. A `.' is not prepended to the string entered."
  143.   ;; EXTENSION may also be a list of extensions instead of a single one.
  144.   ;; Optional MARKER-CHAR is marker to use.
  145.   (interactive "sMark files with extension: \nP")
  146.   (or (listp extension)
  147.       (setq extension (list extension)))
  148.   (dired-mark-files-regexp
  149.    (concat ".";; don't match names with nothing but an extension
  150.        "\\("
  151.        (mapconcat 'regexp-quote extension "\\|")
  152.        "\\)$")
  153.    marker-char))
  154.  
  155. (defun dired-flag-extension (extension)
  156.   "In dired, flag all files with a certain extension for deletion.
  157. A `.' is not prepended to the string entered."
  158.   (interactive "sFlag files with extension: ")
  159.   (dired-mark-extension extension dired-del-marker))
  160.  
  161. (defun dired-cleanup (program)
  162.   "Flag for deletion dispensable files created by PROGRAM.
  163. See variable `dired-cleanup-alist'."
  164.   (interactive
  165.    (list
  166.     (let ((dired-cleanup-history (append dired-cleanup-history
  167.                      (mapcar 'car dired-cleanup-alist))))
  168.       (dired-completing-read
  169.        "Cleanup files for: " dired-cleanup-alist nil t nil
  170.        'dired-cleanup-history))))
  171.   (dired-flag-extension (cdr (assoc program dired-cleanup-alist))))
  172.  
  173. ;;; Commands on marked files whose names also match a regexp.
  174.  
  175. (defun dired-do-rename-regexp (regexp newname &optional arg whole-path)
  176.   "Rename marked files containing REGEXP to NEWNAME.
  177. As each match is found, the user must type a character saying
  178.   what to do with it.  For directions, type \\[help-command] at that time.
  179. NEWNAME may contain \\=\\<n> or \\& as in `query-replace-regexp'.
  180. REGEXP defaults to the last regexp used.
  181. With a zero prefix arg, renaming by regexp affects the complete
  182.   pathname - usually only the non-directory part of file names is used
  183.   and changed."
  184.   (interactive (dired-mark-read-regexp "Rename"))
  185.   (dired-do-create-files-regexp
  186.    (function dired-rename-file)
  187.    "Rename" arg regexp newname whole-path dired-keep-marker-rename))
  188.  
  189. (defun dired-do-copy-regexp (regexp newname &optional arg whole-path)
  190.   "Copy all marked files containing REGEXP to NEWNAME.
  191. See function `dired-rename-regexp' for more info."
  192.   (interactive (dired-mark-read-regexp "Copy"))
  193.   (dired-do-create-files-regexp
  194.    (function dired-copy-file)
  195.    (if dired-copy-preserve-time "Copy [-p]" "Copy")
  196.    arg regexp newname whole-path dired-keep-marker-copy))
  197.  
  198. (defun dired-do-hardlink-regexp (regexp newname &optional arg whole-path)
  199.   "Hardlink all marked files containing REGEXP to NEWNAME.
  200. See function `dired-rename-regexp' for more info."
  201.   (interactive (dired-mark-read-regexp "HardLink"))
  202.   (dired-do-create-files-regexp
  203.    (function add-name-to-file)
  204.    "HardLink" arg regexp newname whole-path dired-keep-marker-hardlink))
  205.  
  206. (defun dired-do-symlink-regexp (regexp newname &optional arg whole-path)
  207.   "Symlink all marked files containing REGEXP to NEWNAME.
  208. See function `dired-rename-regexp' for more info."
  209.   (interactive (dired-mark-read-regexp "SymLink"))
  210.   (dired-do-create-files-regexp
  211.    (function make-symbolic-link)
  212.    "SymLink" arg regexp newname whole-path dired-keep-marker-symlink))
  213.  
  214. (defun dired-do-relsymlink-regexp (regexp newname &optional whole-path)
  215.   "RelSymlink all marked files containing REGEXP to NEWNAME.
  216. See functions `dired-rename-regexp' and `dired-do-relsymlink'
  217.   for more info."
  218.   (interactive (dired-mark-read-regexp "RelSymLink"))
  219.   (dired-do-create-files-regexp
  220.    (function dired-make-relative-symlink)
  221.    "RelSymLink" nil regexp newname whole-path dired-keep-marker-symlink))
  222.  
  223. ;;;; Modifying the case of file names.
  224.  
  225. (defun dired-create-files-non-directory
  226.   (file-creator basename-constructor operation arg)
  227.   ;; Perform FILE-CREATOR on the non-directory part of marked files
  228.   ;; using function BASENAME-CONSTRUCTOR, with query for each file.
  229.   ;; OPERATION like in dired-create-files, ARG like in dired-get-marked-files.
  230.   (let (rename-non-directory-query)
  231.     (dired-create-files
  232.      file-creator
  233.      operation
  234.      (dired-get-marked-files nil arg)
  235.      (function
  236.       (lambda (from)
  237.     (let ((to (concat (file-name-directory from)
  238.               (funcall basename-constructor
  239.                    (file-name-nondirectory from)))))
  240.       (and (let ((help-form (format "\
  241. Type SPC or `y' to %s one file, DEL or `n' to skip to next,
  242. `!' to %s all remaining matches with no more questions."
  243.                     (downcase operation)
  244.                     (downcase operation))))
  245.          (dired-query 'rename-non-directory-query
  246.                   (concat operation " `%s' to `%s'")
  247.                   (dired-make-relative from)
  248.                   (dired-make-relative to)))
  249.            to))))
  250.      dired-keep-marker-rename)))
  251.  
  252. (defun dired-rename-non-directory (basename-constructor operation arg)
  253.   (dired-create-files-non-directory
  254.    (function dired-rename-file)
  255.    basename-constructor operation arg))
  256.  
  257. (defun dired-upcase (&optional arg)
  258.   "Rename all marked (or next ARG) files to upper case."
  259.   (interactive "P")
  260.   (dired-rename-non-directory (function upcase) "Rename upcase" arg))
  261.  
  262. (defun dired-downcase (&optional arg)
  263.   "Rename all marked (or next ARG) files to lower case."
  264.   (interactive "P")
  265.   (dired-rename-non-directory (function downcase) "Rename downcase" arg))
  266.  
  267. ;;; end of dired-rgxp.el
  268.